home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / htmlform.scm < prev    next >
Text File  |  1999-04-19  |  30KB  |  850 lines
  1. ;;; "htmlform.scm" Generate HTML 2.0 forms; service CGI requests. -*-scheme-*-
  2. ; Copyright 1997, 1998 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'sort)
  21. (require 'scanf)
  22. (require 'printf)
  23. (require 'line-i/o)
  24. (require 'parameters)
  25. (require 'fluid-let)
  26. (require 'dynamic-wind)
  27. (require 'pretty-print)
  28. (require 'object->string)
  29. (require 'string-case)
  30. (require 'string-port)
  31. (require 'string-search)
  32. (require 'database-utilities)
  33. (require 'common-list-functions)
  34.  
  35. ;;;;@code{(require 'html-form)}
  36.  
  37. ;;@body Procedure names starting with @samp{html:} send their output
  38. ;;to the port @0.  @0 is initially the current output port.
  39. (define *html:output-port* (current-output-port))
  40.  
  41. (define (html:printf . args) (apply fprintf *html:output-port* args))
  42.  
  43. ;;@body Returns a string with character substitutions appropriate to
  44. ;;send @1 as an @dfn{attribute-value}.
  45. (define (make-atval txt)        ; attribute-value
  46.   (if (symbol? txt) (set! txt (symbol->string txt)))
  47.   (if (number? txt)
  48.       (number->string txt)
  49.       (string-subst (if (string? txt) txt (object->string txt))
  50.             "&" "&"
  51.             "\"" """
  52.             "<" "<"
  53.             ">" ">")))
  54.  
  55. ;;@body Returns a string with character substitutions appropriate to
  56. ;;send @1 as an @dfn{plain-text}.
  57. (define (make-plain txt)        ; plain-text `Data Characters'
  58.   (if (symbol? txt) (set! txt (symbol->string txt)))
  59.   (if (number? txt)
  60.       (number->string txt)
  61.       (string-subst (if (string? txt) txt (object->string txt))
  62.             "&" "&"
  63.             "<" "<"
  64.             ">" ">")))
  65.  
  66. ;;@args title backlink tags ...
  67. ;;@args title backlink
  68. ;;@args title
  69. ;;
  70. ;;Outputs headers for an HTML page named @1.  If string arguments @2
  71. ;;... are supplied they are printed verbatim within the @t{<HEAD>}
  72. ;;section.
  73. (define (html:start-page title . args)
  74.   (define backlink (if (null? args) #f (car args)))
  75.   (if (not (null? args)) (set! args (cdr args)))
  76.   (html:printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n")
  77.   (html:printf "<HTML>\\n")
  78.   (html:comment "HTML by SLIB"
  79.         "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")
  80.   (html:printf "<HEAD>%s<TITLE>%s</TITLE></HEAD>\\n"
  81.            (apply string-append args) (make-plain title))
  82.   (html:printf "<BODY><H1>%s</H1>\\n"
  83.            (or backlink (make-plain title))))
  84.  
  85. ;;@body Outputs HTML codes to end a page.
  86. (define (html:end-page)
  87.   (html:printf "</BODY>\\n")
  88.   (html:printf "</HTML>\\n"))
  89.  
  90. ;;@body Writes (using @code{html:printf}) the strings @1, @2 as
  91. ;;@dfn{PRE}formmated plain text (rendered in fixed-width font).
  92. ;;Newlines are inserted between @1, @2.  HTML tags (@samp{<tag>})
  93. ;;within @2 will be visible verbatim.
  94. (define (html:pre line1 . lines)
  95.   (html:printf "<PRE>\\n%s" (make-plain line1))
  96.   (for-each (lambda (line) (html:printf "\\n%s" (make-plain line))) lines)
  97.   (html:printf "</PRE>\\n"))
  98.  
  99. ;;@body Writes (using @code{html:printf}) the strings @1 as HTML
  100. ;;comments.
  101. (define (html:comment line1 . lines)
  102.   (html:printf "<!")
  103.   (if (substring? "--" line1)
  104.       (slib:error 'html:comment "line contains --" line1)
  105.       (html:printf "--%s--" line1))
  106.   (for-each (lambda (line)
  107.           (if (substring? "--" line)
  108.           (slib:error 'html:comment "line contains --" line)
  109.           (html:printf "\\n  --%s--" line)))
  110.         lines)
  111.   (html:printf ">\\n"))
  112.  
  113. ;;@section HTML Tables
  114.  
  115. ;;@body
  116. (define (html:start-table caption)
  117.   (html:printf "<TABLE BORDER WIDTH=\"100%%\">\\n")
  118.   (html:printf "<CAPTION ALIGN=BOTTOM>%s</CAPTION>\\n" (make-plain caption)))
  119.  
  120. ;;@body
  121. (define (html:end-table)
  122.   (html:printf "</TABLE>\\n"))
  123.  
  124. ;;@body Outputs a heading row for the currently-started table.
  125. (define (html:heading columns)
  126.   (html:printf "<TR VALIGN=\"TOP\">\\n")
  127.   (for-each (lambda (datum) (html:printf "<TH>%s\\n" (or datum ""))) columns))
  128.  
  129. ;;@body Outputs a heading row with column-names @1 linked to URLs @2.
  130. (define (html:href-heading columns urls)
  131.   (html:heading
  132.    (map (lambda (column url)
  133.       (if url
  134.           (sprintf #f "<A HREF=\"%s\">%s</A>" url column)
  135.           column))
  136.     columns urls)))
  137.  
  138. ;;@args k foreigns
  139. ;;
  140. ;;The positive integer @1 is the primary-key-limit (number of
  141. ;;primary-keys) of the table.  @2 is a list of the filenames of
  142. ;;foreign-key field pages and #f for non foreign-key fields.
  143. ;;
  144. ;;@0 returns a procedure taking a row for its single argument.  This
  145. ;;returned procedure prints the table row to @var{*html:output-port*}.
  146. (define (make-row-converter pkl foreigns)
  147.   (lambda (data-row)
  148.     (define anchored? #f)
  149.     (define (present datum)
  150.       (cond ((or (string? datum) (symbol? datum))
  151.          (html:printf "%s" (make-plain datum)))
  152.         (else
  153.          (html:printf
  154.           "<PRE>\\n%s</PRE>\\n"
  155.           (make-plain (call-with-output-string
  156.                (lambda (port)
  157.                  (pretty-print datum port))))))))
  158.     (html:printf "<TR VALIGN=\"TOP\">")
  159.     (for-each (lambda (datum foreign)
  160.         (html:printf "<TD>")
  161.         (cond ((not datum))
  162.               ((null? datum))
  163.               ((not anchored?)
  164.                (html:printf "<A NAME=\"")
  165.                (cond
  166.             ((zero? pkl)
  167.              (html:printf "%s" (make-atval datum)))
  168.             (else (html:printf
  169.                    "%s" (make-atval (car data-row)))
  170.                   (do ((idx 1 (+ 1 idx))
  171.                    (contents (cdr data-row) (cdr contents)))
  172.                   ((>= idx pkl))
  173.                 (html:printf
  174.                  " %s" (make-atval (car contents))))))
  175.                (html:printf "\">")
  176.                (set! anchored? (not (zero? pkl)))))
  177.         (cond ((not datum)) ((null? datum))
  178.               ((not foreign) (present datum))
  179.               ((zero? pkl)
  180.                (html:printf "<A HREF=\"%s\">" foreign)
  181.                (present datum)
  182.                (html:printf "</A>"))
  183.               (else
  184.                (html:printf "<A HREF=\"%s#%s\">"
  185.                     foreign (make-atval datum))
  186.                (present datum)
  187.                (html:printf "</A>"))))
  188.           data-row foreigns)
  189.     (html:printf "\\n")))
  190.  
  191. ;;@body
  192. ;;Returns the symbol @1 converted to a filename.
  193. (define (table-name->filename table-name)
  194.   (and table-name (string-append
  195.            (string-subst (symbol->string table-name) "*" "" ":" "_")
  196.            ".html")))
  197.  
  198. (define (table-name->column-table-name db table-name)
  199.   ((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name)
  200.    table-name))
  201.  
  202. ;;@args caption db table-name match-key1 @dots{}
  203. ;;Writes HTML for @2 table @3 to @var{*html:output-port*}.
  204. ;;
  205. ;;The optional @4 @dots{} arguments restrict actions to a subset of
  206. ;;the table.  @xref{Table Operations, match-key}.
  207. (define (table->html caption db table-name . args)
  208.   (let* ((table ((db 'open-table) table-name #f))
  209.      (foreigns (table 'column-foreigns))
  210.      (tags (map table-name->filename foreigns))
  211.      (names (table 'column-names))
  212.      (primlim (table 'primary-limit)))
  213.     (html:start-table caption)
  214.     (html:href-heading
  215.      names
  216.      (append (make-list primlim (table-name->filename
  217.                  (table-name->column-table-name db table-name)))
  218.          (make-list (- (length names) primlim) #f)))
  219.     (html:heading (table 'column-domains))
  220.     (html:href-heading foreigns tags)
  221.     (html:heading (table 'column-types))
  222.     (apply (table 'for-each-row) (make-row-converter primlim tags) args)
  223.     (html:end-table)))
  224.  
  225. ;;@body
  226. ;;Writes a complete HTML page to @var{*html:output-port*}.  The string
  227. ;;@3 names the page which refers to this one.
  228. (define (table->page db table-name index-filename)
  229.   (dynamic-wind
  230.       (lambda ()
  231.     (if index-filename
  232.         (html:start-page
  233.          table-name
  234.          (sprintf #f "<A HREF=\"%s#%s\">%s</A>"
  235.               index-filename
  236.               (make-atval table-name)
  237.               (make-plain table-name)))
  238.         (html:start-page table-name)))
  239.       (lambda () (table->html table-name db table-name))
  240.       html:end-page))
  241.  
  242. ;;@body
  243. ;;Writes HTML for the catalog table of @1 to @var{*html:output-port*}.
  244. (define    (catalog->html db caption)
  245.   (html:start-table caption)
  246.   (html:heading '(table columns))
  247.   ((((db 'open-table) '*catalog-data* #f) 'for-each-row)
  248.    (lambda (row)
  249.      (cond ((and (eq? '*columns* (caddr row))
  250.          (not (eq? '*columns* (car row)))))
  251.        (else ((make-row-converter
  252.            0 (list (table-name->filename (car row))
  253.                (table-name->filename (caddr row))))
  254.           (list (car row) (caddr row))))))))
  255.  
  256. ;;@body
  257. ;;Writes a complete HTML page for the catalog of @1 to
  258. ;;@var{*html:output-port*}.
  259. (define (catalog->page db caption)
  260.   (dynamic-wind
  261.       (lambda () (html:start-page caption))
  262.       (lambda ()
  263.     (catalog->html db caption)
  264.     (html:end-table))
  265.       html:end-page))
  266.  
  267. ;;@section HTML Forms
  268.  
  269. (define (html:dt-strong-doc name doc)
  270.   (if (and (string? doc) (not (equal? "" doc)))
  271.       (html:printf "<DT><STRONG>%s</STRONG> (%s)\\n"
  272.            (make-plain name) (make-plain doc))
  273.       (html:printf "<DT><STRONG>%s</STRONG>\\n" (make-plain name))))
  274.  
  275. (define (html:checkbox name doc pname)
  276.   (html:printf "<DT><INPUT TYPE=CHECKBOX NAME=%#a VALUE=T>\\n"
  277.            (make-atval pname))
  278.   (if (and (string? doc) (not (equal? "" doc)))
  279.       (html:printf "<DD><STRONG>%s</STRONG> (%s)\\n"
  280.            (make-plain name) (make-plain doc))
  281.       (html:printf "<DD><STRONG>%s</STRONG>\\n" (make-plain name))))
  282.  
  283. (define (html:text name doc pname default)
  284.   (cond (default
  285.       (html:dt-strong-doc name doc)
  286.       (html:printf "<DD><INPUT NAME=%#a SIZE=%d VALUE=%#a>\\n"
  287.                (make-atval pname)
  288.                (max 20 (string-length
  289.                 (if (symbol? default)
  290.                     (symbol->string default) default)))
  291.                (make-atval default)))
  292.     (else
  293.      (html:dt-strong-doc name doc)
  294.      (html:printf "<DD><INPUT NAME=%#a>\\n" (make-atval pname)))))
  295.  
  296. (define (html:text-area name doc pname default-list)
  297.   (html:dt-strong-doc name doc)
  298.   (html:printf "<DD><TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n"
  299.            (make-atval pname) (max 2 (length default-list))
  300.            (apply max 32 (map (lambda (d) (string-length
  301.                            (if (symbol? d)
  302.                            (symbol->string d)
  303.                            d)))
  304.                   default-list)))
  305.   (for-each (lambda (line) (html:printf "%s\\n" (make-plain line))) default-list)
  306.   (html:printf "</TEXTAREA>\\n"))
  307.  
  308. (define (html:s<? s1 s2)
  309.   (if (and (number? s1) (number? s2))
  310.       (< s1 s2)
  311.       (string<? (if (symbol? s1) (symbol->string s1) s1)
  312.         (if (symbol? s2) (symbol->string s2) s2))))
  313.  
  314. (define (html:select name doc pname arity default-list value-list)
  315.   (set! value-list (sort! value-list html:s<?))
  316.   (html:dt-strong-doc name doc)
  317.   (html:printf "<DD><SELECT NAME=%#a SIZE=%d%s>\\n"
  318.            (make-atval pname)
  319.            (case arity
  320.          ((single optional) 1)
  321.          ((nary nary1) 5))
  322.            (case arity
  323.          ((nary nary1) " MULTIPLE")
  324.          (else "")))
  325.   (for-each (lambda (value)
  326.           (html:printf "<OPTION VALUE=%#a%s>%s\\n"
  327.                (make-atval value)
  328.                (if (member value default-list)
  329.                    " SELECTED" "")
  330.                (make-plain value)))
  331.         (case arity
  332.           ((optional nary) (cons (string->symbol "") value-list))
  333.           (else value-list)))
  334.   (html:printf "</SELECT>\\n"))
  335.  
  336. (define (html:buttons name doc pname arity default-list value-list)
  337.   (set! value-list (sort! value-list html:s<?))
  338.   (html:dt-strong-doc name doc)
  339.   (html:printf "<DD><MENU>")
  340.   (case arity
  341.     ((single optional)
  342.      (for-each (lambda (value)
  343.          (html:printf
  344.           "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n"
  345.           (make-atval pname) (make-atval value)
  346.           (if (member value default-list) " CHECKED" "")
  347.           (make-plain value)))
  348.            value-list))
  349.     ((nary nary1)
  350.      (for-each (lambda (value)
  351.          (html:printf
  352.           "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n"
  353.           (make-atval pname) (make-atval value)
  354.           (if (member value default-list) " CHECKED" "")
  355.           (make-plain value)))
  356.            value-list)))
  357.   (html:printf "</MENU>"))
  358.  
  359. ;;@body The symbol @1 is either @code{get}, @code{head}, @code{post},
  360. ;;@code{put}, or @code{delete}.  @0 prints the header for an HTML
  361. ;;@dfn{form}.
  362. (define (html:start-form method action)
  363.   (cond ((not (memq method '(get head post put delete)))
  364.      (slib:error 'html:start-form "method unknown:" method)))
  365.   (html:printf "<FORM METHOD=%#a ACTION=%#a>\\n"
  366.            (make-atval method) (make-atval action))
  367.   (html:printf "<DL>\\n"))
  368.  
  369. ;;@body @0 prints the footer for an HTML @dfn{form}.  The string @2
  370. ;;appears on the button which submits the form.
  371. (define (html:end-form pname submit-label)
  372.   (html:printf "</DL>\\n")
  373.   (html:printf "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a> <INPUT TYPE=RESET>\\n"
  374.            (make-atval '*command*) (make-atval submit-label))
  375.   (html:printf "</FORM><HR>\\n"))
  376.  
  377. (define (html:generate-form comname method action docu pnames docs aliases
  378.                 arities types default-lists value-lists)
  379.   (define aliast (map list pnames))
  380.   (for-each (lambda (alias) (if (> (string-length (car alias)) 1)
  381.                 (let ((apr (assq (cadr alias) aliast)))
  382.                   (set-cdr! apr (cons (car alias) (cdr apr))))))
  383.         aliases)
  384.   (dynamic-wind
  385.    (lambda ()
  386.      (html:printf "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
  387.           (make-plain comname) (make-plain docu))
  388.      (html:start-form 'post action))
  389.    (lambda ()
  390.      (for-each
  391.       (lambda (pname doc aliat arity default-list value-list)
  392.     (define longname
  393.       (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat)))
  394.     (set! longname (if (null? longname) #f (car longname)))
  395.     (cond (longname
  396.            (case (length value-list)
  397.          ((0) (case arity
  398.             ((boolean) (html:checkbox longname doc pname 'Y))
  399.             ((single optional)
  400.              (html:text longname doc pname
  401.                     (if (null? default-list)
  402.                     #f (car default-list))))
  403.             (else
  404.              (html:text-area longname doc pname default-list))))
  405.          ((1) (html:checkbox longname doc pname (car value-list)))
  406.          (else ((case arity
  407.               ((single optional) html:select)
  408.               (else html:buttons))
  409.             longname doc pname arity default-list value-list))))))
  410.       pnames docs aliast arities default-lists value-lists))
  411.    (lambda ()
  412.      (html:end-form comname comname))))
  413.  
  414. ;;@body The symbol @2 names a command table in the @1 relational
  415. ;;database.
  416. ;;
  417. ;;@0 writes an HTML-2.0 @dfn{form} for command @3 to the
  418. ;;current-output-port.  The @samp{SUBMIT} button, which is labeled @3,
  419. ;;invokes the URI @5 with method @4 with a hidden attribute
  420. ;;@code{*command*} bound to the command symbol submitted.
  421. ;;
  422. ;;An action may invoke a CGI script
  423. ;;(@samp{http://www.my-site.edu/cgi-bin/search.cgi}) or HTTP daemon
  424. ;;(@samp{http://www.my-site.edu:8001}).
  425. ;;
  426. ;;This example demonstrates how to create a HTML-form for the @samp{build}
  427. ;;command.
  428. ;;
  429. ;;@example
  430. ;;(require (in-vicinity (implementation-vicinity) "build.scm"))
  431. ;;(call-with-output-file "buildscm.html"
  432. ;;  (lambda (port)
  433. ;;    (fluid-let ((*html:output-port* port))
  434. ;;      (html:start-page 'commands)
  435. ;;      (command->html
  436. ;;       build '*commands* 'build 'post
  437. ;;       (or "/cgi-bin/build.cgi"
  438. ;;           "http://localhost:8081/buildscm"))
  439. ;;      html:end-page)))
  440. ;;@end example
  441. (define (command->html rdb command-table command method action)
  442.   (define rdb-open (rdb 'open-table))
  443.   (define (row-refer idx) (lambda (row) (list-ref row idx)))
  444.   (let ((comtab (rdb-open command-table #f))
  445.     (domain->type ((rdb-open '*domains-data* #f) 'get 'type-id))
  446.     (get-domain-choices
  447.      (let ((for-tab-name
  448.         ((rdb-open '*domains-data* #f) 'get 'foreign-table)))
  449.        (lambda (domain-name)
  450.          (define tab-name (for-tab-name domain-name))
  451.          (if tab-name
  452.          (do ((dlst (((rdb-open tab-name #f) 'get* 1)) (cdr dlst))
  453.               (out '() (if (member (car dlst) (cdr dlst))
  454.                    out (cons (car dlst) out))))
  455.              ((null? dlst) out))
  456.          '())))))
  457.     (define row-ref
  458.       (let ((names (comtab 'column-names)))
  459.     (lambda (row name) (list-ref row (position name names)))))
  460.     (let* ((command:row ((comtab 'row:retrieve) command))
  461.        (parameter-table (rdb-open (row-ref command:row 'parameters) #f))
  462.        (pcnames (parameter-table 'column-names))
  463.        (param-rows (sort! ((parameter-table 'row:retrieve*))
  464.                   (lambda (r1 r2) (< (car r1) (car r2))))))
  465.       (let ((domains (map (row-refer (position 'domain pcnames)) param-rows))
  466.         (parameter-names
  467.          (rdb-open (row-ref command:row 'parameter-names) #f)))
  468.     (html:generate-form
  469.      command
  470.      method
  471.      action
  472.      (row-ref command:row 'documentation)
  473.      (map (row-refer (position 'name pcnames)) param-rows)
  474.      (map (row-refer (position 'documentation pcnames)) param-rows)
  475.      (map list ((parameter-names 'get* 'name))
  476.           (map (parameter-table 'get 'name)
  477.            ((parameter-names 'get* 'parameter-index))))
  478.      (map (row-refer (position 'arity pcnames)) param-rows)
  479.      (map domain->type domains)
  480.      (map cdr (fill-empty-parameters
  481.            (map slib:eval
  482.             (map (row-refer (position 'defaulter pcnames))
  483.                  param-rows))
  484.            (make-parameter-list
  485.             (map (row-refer (position 'name pcnames)) param-rows))))
  486.      (map get-domain-choices domains))))))
  487.  
  488. (define (cgi:process-% str)
  489.   (define len (string-length str))
  490.   (define (sub str)
  491.     (cond
  492.      ((string-index str #\%)
  493.       => (lambda (idx)
  494.        (if (and (< (+ 2 idx) len)
  495.             (string->number (substring str (+ 1 idx) (+ 2 idx)) 16)
  496.             (string->number (substring str (+ 2 idx) (+ 3 idx)) 16))
  497.            (string-append
  498.         (substring str 0 idx)
  499.         (string (integer->char
  500.              (string->number
  501.               (substring str (+ 1 idx) (+ 3 idx))
  502.               16)))
  503.         (sub (substring str (+ 3 idx) (string-length str)))))))
  504.      (else str)))
  505.   (sub str))
  506.  
  507. (define (form:split-lines txt)
  508.   (let ((idx (string-index txt #\newline))
  509.     (carriage-return (integer->char #xd)))
  510.     (if idx
  511.     (cons (substring txt 0
  512.              (if (and (positive? idx)
  513.                   (char=? carriage-return
  514.                       (string-ref txt (+ -1 idx))))
  515.                  (+ -1 idx)
  516.                  idx))
  517.           (form:split-lines
  518.            (substring txt (+ 1 idx) (string-length txt))))
  519.     (list txt))))
  520.  
  521. (define (form-urlencoded->query-alist txt)
  522.   (if (symbol? txt) (set! txt (symbol->string txt)))
  523.   (set! txt (string-subst txt " " "" "+" " "))
  524.   (do ((lst '())
  525.        (edx (string-index txt #\=)
  526.         (string-index txt #\=)))
  527.       ((not edx) lst)
  528.     (let* ((rxt (substring txt (+ 1 edx) (string-length txt)))
  529.        (adx (string-index rxt #\&))
  530.        (name (cgi:process-% (substring txt 0 edx))))
  531.       (set!
  532.        lst (append
  533.         lst
  534.         (map
  535.          (lambda (value) (list (string->symbol name)
  536.                    (if (equal? "" value) #f value)))
  537.          (form:split-lines
  538.           (cgi:process-% (substring rxt 0 (or adx (string-length rxt))))))))
  539.       (set! txt (if adx (substring rxt (+ 1 adx) (string-length rxt)) "")))))
  540.  
  541. (define (query-alist->parameter-list alist optnames arities types)
  542.   (define (can-take-arg? opt)
  543.     (not (eq? (list-ref arities (position opt optnames)) 'boolean)))
  544.   (let ((parameter-list (make-parameter-list optnames)))
  545.     (for-each
  546.      (lambda (lst)
  547.        (let* ((value (cadr lst))
  548.           (name (car lst)))
  549.      (cond ((not (can-take-arg? name))
  550.         (adjoin-parameters! parameter-list (list name #t)))
  551.            (value
  552.         (adjoin-parameters!
  553.          parameter-list
  554.          (let ((type (list-ref types (position name optnames))))
  555.            (case type
  556.              ((expression) (list name value))
  557.              ((symbol)
  558.               (if (string? value)
  559.               (call-with-input-string
  560.                value
  561.                (lambda (port)
  562.                  (do ((tok (scanf-read-list " %s" port)
  563.                        (scanf-read-list " %s" port))
  564.                   (lst '()
  565.                        (cons (string-ci->symbol (car tok))
  566.                          lst)))
  567.                  ((or (null? tok) (eof-object? tok))
  568.                   (cons name lst)))))
  569.               (list name (coerce value type))))
  570.              (else (list name (coerce value type))))))))))
  571.      alist)
  572.     parameter-list))
  573.  
  574. ;;@c node HTTP and CGI service, Printing Scheme, HTML Forms, Textual Conversion Packages
  575. ;;@section HTTP and CGI service
  576.  
  577. ;;@code{(require 'html-form)}
  578.  
  579. ;;;; Now that we have generated the HTML form, process the ensuing CGI request.
  580.  
  581. ;;@body Reads a @samp{"POST"} or @samp{"GET"} query from
  582. ;;@code{(current-input-port)} and executes the encoded command from @2
  583. ;;in relational-database @1.
  584. ;;
  585. ;;This example puts up a plain-text page in response to a CGI query.
  586. ;;
  587. ;;@example
  588. ;;(display "Content-Type: text/plain") (newline) (newline)
  589. ;;(require 'html-form)
  590. ;;(load (in-vicinity (implementation-vicinity) "build.scm"))
  591. ;;(cgi:serve-command build '*commands*)
  592. ;;@end example
  593. (define (cgi:serve-command rdb command-table)
  594.   (serve-urlencoded-command rdb command-table (cgi:read-query-string)))
  595.  
  596. ;;@body Reads attribute-value pairs from @3, converts them to
  597. ;;parameters and invokes the @1 command named by the parameter
  598. ;;@code{*command*}.
  599. (define (serve-urlencoded-command rdb command-table urlencoded)
  600.   (let* ((alist (form-urlencoded->query-alist urlencoded))
  601.      (comname #f)
  602.      (comtab ((rdb 'open-table) command-table #f))
  603.      (names (comtab 'column-names))
  604.      (row-ref (lambda (row name) (list-ref row (position name names))))
  605.      (comgetrow (comtab 'row:retrieve)))
  606.     (set! alist (remove-if (lambda (elt)
  607.                  (cond ((not (and (list? elt) (pair? elt)
  608.                           (eq? '*command* (car elt)))) #f)
  609.                    (comname
  610.                     (slib:error
  611.                      'serve-urlencoded-command
  612.                      'more-than-one-command? comname
  613.                      (string->symbol (cadr elt))))
  614.                    (else (set! comname
  615.                            (string-ci->symbol (cadr elt)))
  616.                      #t)))
  617.                alist))
  618.     (let* ((command:row (comgetrow comname))
  619.        (parameter-table ((rdb 'open-table)
  620.                  (row-ref command:row 'parameters) #f))
  621.        (comval ((slib:eval (row-ref command:row 'procedure)) rdb))
  622.        (options ((parameter-table 'get* 'name)))
  623.        (positions ((parameter-table 'get* 'index)))
  624.        (arities ((parameter-table 'get* 'arity)))
  625.        (defaulters (map slib:eval ((parameter-table 'get* 'defaulter))))
  626.        (domains ((parameter-table 'get* 'domain)))
  627.        (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id)
  628.                domains))
  629.        (dirs (map (rdb 'domain-checker) domains)))
  630.  
  631.        (let* ((params (query-alist->parameter-list alist options arities types))
  632.          (fparams (fill-empty-parameters defaulters params)))
  633.     (and (list? fparams) (check-parameters dirs fparams)
  634.          (comval fparams))))))
  635.  
  636. (define (serve-query-alist-command rdb command-table alist)
  637.   (let ((command #f))
  638.     (set! alist (remove-if (lambda (elt)
  639.                  (cond ((not (and (list? elt) (pair? elt)
  640.                           (eq? '*command* (car elt)))) #f)
  641.                    (command
  642.                     (slib:error
  643.                      'serve-query-alist-command
  644.                      'more-than-one-command? command
  645.                      (string->symbol (cadr elt))))
  646.                    (else (set! command
  647.                            (string-ci->symbol (cadr elt)))
  648.                      #t)))
  649.                alist))
  650.     ((make-command-server rdb command-table)
  651.      command
  652.      (lambda (comname comval options positions
  653.               arities types defaulters dirs aliases)
  654.        (let* ((params (query-alist->parameter-list alist options arities types))
  655.           (fparams (fill-empty-parameters defaulters params)))
  656.      (and (list? fparams) (check-parameters dirs fparams)
  657.           (apply comval
  658.              (parameter-list->arglist positions arities fparams))))))))
  659.  
  660. (define http:crlf (string (integer->char 13) #\newline))
  661. (define (http:read-header port)
  662.   (define alist '())
  663.   (do ((line (read-line port) (read-line port)))
  664.       ((or (zero? (string-length line))
  665.        (and (= 1 (string-length line))
  666.         (char-whitespace? (string-ref line 0)))
  667.        (eof-object? line))
  668.        (if (and (= 1 (string-length line))
  669.         (char-whitespace? (string-ref line 0)))
  670.        (set! http:crlf (string (string-ref line 0) #\newline)))
  671.        (if (eof-object? line) line alist))
  672.     (let ((len (string-length line))
  673.       (idx (string-index line #\:)))
  674.       (if (char-whitespace? (string-ref line (+ -1 len)))
  675.       (set! len (+ -1 len)))
  676.       (and idx (do ((idx2 (+ idx 1) (+ idx2 1)))
  677.            ((or (>= idx2 len)
  678.             (not (char-whitespace? (string-ref line idx2))))
  679.             (set! alist
  680.               (cons
  681.                (cons (string-ci->symbol (substring line 0 idx))
  682.                  (substring line idx2 len))
  683.                alist)))))
  684.       ;;Else -- ignore malformed line
  685.       ;;(else (slib:error 'http:read-header 'malformed-input line))
  686.       )))
  687.  
  688. (define (http:read-query-string request-line header port)
  689.   (case (car request-line)
  690.     ((get head)
  691.      (let* ((request-uri (cadr request-line))
  692.         (len (string-length request-uri)))
  693.        (and (> len 3)
  694.         (string-index request-uri #\?)
  695.         (substring request-uri
  696.                (+ 1 (string-index request-uri #\?))
  697.                (if (eqv? #\/ (string-ref request-uri (+ -1 len)))
  698.                (+ -1 len)
  699.                len)))))
  700.     ((post put delete)
  701.      (let ((content-length (assq 'content-length header)))
  702.        (and content-length
  703.         (set! content-length (string->number (cdr content-length))))
  704.        (and content-length
  705.         (let ((str (make-string content-length #\ )))
  706.           (do ((idx 0 (+ idx 1)))
  707.           ((>= idx content-length)
  708.            (if (>= idx (string-length str)) str (substring str 0 idx)))
  709.         (let ((chr (read-char port)))
  710.           (if (char? chr)
  711.               (string-set! str idx chr)
  712.               (set! content-length idx))))))))
  713.     (else #f)))
  714.  
  715. (define (http:send-status-line status-code reason)
  716.   (html:printf "HTTP/1.1 %d %s%s" status-code reason http:crlf))
  717. (define (http:send-header alist)
  718.   (for-each (lambda (pair)
  719.           (html:printf "%s: %s%s" (car pair) (cdr pair) http:crlf))
  720.         alist)
  721.   (html:printf http:crlf))
  722.  
  723. (define *http:byline*
  724.   "<A HREF=http://swissnet.ai.mit.edu/~jaffer/SLIB.html>SLIB </A>HTTP/1.1 server")
  725.  
  726. (define (http:send-error-page code str port)
  727.   (fluid-let ((*html:output-port* port))
  728.     (http:send-status-line code str)
  729.     (http:send-header '(("Content-Type" . "text/html")))
  730.     (html:start-page (sprintf #f "%d %s" code str))
  731.     (and *http:byline* (html:printf "<HR>\\n%s\\n" *http:byline*))
  732.     (html:end-page)))
  733.  
  734. ;;@body reads the @dfn{query-string} from @1.  If this is a valid
  735. ;;@samp{"POST"} or @samp{"GET"} query, then @0 calls @3 with two
  736. ;;arguments, the query-string and the header-alist.
  737. ;;
  738. ;;Otherwise, @0 replies (to @2) with appropriate HTML describing the
  739. ;;problem.
  740. (define (http:serve-query input-port output-port serve-proc)
  741.   (let ((request-line (http:read-request-line input-port)))
  742.     (cond ((not request-line)
  743.        (http:send-error-page 400 "Bad Request" output-port))
  744.       ((string? (car request-line))
  745.        (http:send-error-page 501 "Not Implemented" output-port))
  746.       ((not (case (car request-line)
  747.           ((get post) #t)
  748.           (else #f)))
  749.        (http:send-error-page 405 "Method Not Allowed" output-port))
  750.       (else (let* ((header (http:read-header input-port))
  751.                (query-string
  752.             (http:read-query-string
  753.              request-line header input-port)))
  754.           (cond ((not query-string)
  755.              (http:send-error-page 400 "Bad Request" output-port))
  756.             (else (http:send-status-line 200 "OK")
  757.                   (serve-proc query-string header))))))))
  758.  
  759. ;;@ This example services HTTP queries from port 8081:
  760. ;;
  761. ;;@example
  762. ;;(define socket (make-stream-socket AF_INET 0))
  763. ;;(socket:bind socket 8081)
  764. ;;(socket:listen socket 10)
  765. ;;(dynamic-wind
  766. ;; (lambda () #f)
  767. ;; (lambda ()
  768. ;;   (do ((port (socket:accept socket)
  769. ;;              (socket:accept socket)))
  770. ;;       (#f)
  771. ;;     (dynamic-wind
  772. ;;      (lambda () #f)
  773. ;;      (lambda ()
  774. ;;        (fluid-let ((*html:output-port* port))
  775. ;;          (http:serve-query
  776. ;;           port port
  777. ;;           (lambda (query-string header)
  778. ;;             (http:send-header
  779. ;;              '(("Content-Type" . "text/plain")))
  780. ;;             (with-output-to-port port
  781. ;;               (lambda ()
  782. ;;                 (serve-urlencoded-command
  783. ;;                  build '*commands* query-string)))))))
  784. ;;      (lambda () (close-port port)))))
  785. ;; (lambda () (close-port socket)))
  786. ;;@end example
  787.  
  788. (define (http:read-start-line port)
  789.   (do ((line (read-line port) (read-line port)))
  790.       ((or (not (equal? "" line)) (eof-object? line)) line)))
  791.  
  792. ;;@body Reads the first non-blank line from @1 and, if successful,
  793. ;;returns a list of three itmes from the request-line:
  794. ;;
  795. ;;@enumerate 0
  796. ;;
  797. ;;@item Method
  798. ;;
  799. ;;Either one of the symbols @code{options}, @code{get}, @code{head},
  800. ;;@code{post}, @code{put}, @code{delete}, or @code{trace}; Or a string.
  801. ;;
  802. ;;@item Request-URI
  803. ;;
  804. ;;A string.  At the minimum, it will be the string @samp{"/"}.
  805. ;;
  806. ;;@item HTTP-Version
  807. ;;
  808. ;;A string.  For example, @samp{HTTP/1.0}.
  809. ;;@end enumerate
  810. (define (http:read-request-line port)
  811.   (let ((lst (scanf-read-list "%s %s %s %s" (http:read-start-line port))))
  812.     (and (list? lst)
  813.      (= 3 (length lst))
  814.      (let ((method
  815.         (assoc
  816.          (car lst)
  817.          '(("OPTIONS" . options) ; Section 9.2
  818.            ("GET"     . get)    ; Section 9.3
  819.            ("HEAD"    . head)    ; Section 9.4
  820.            ("POST"    . post)    ; Section 9.5
  821.            ("PUT"     . put)    ; Section 9.6
  822.            ("DELETE"  . delete)    ; Section 9.7
  823.            ("TRACE"   . trace)    ; Section 9.8
  824.            ))))
  825.        (cons (if (pair? method) (cdr method) (car lst)) (cdr lst))))))
  826.  
  827. ;;@body Reads the @dfn{query-string} from @code{(current-input-port)}.
  828. ;;@0 reads a @samp{"POST"} or @samp{"GET"} queries, depending on the
  829. ;;value of @code{(getenv "REQUEST_METHOD")}.
  830. (define (cgi:read-query-string)
  831.   (define request-method (getenv "REQUEST_METHOD"))
  832.   (cond ((and request-method (string-ci=? "GET" request-method))
  833.      (getenv "QUERY_STRING"))
  834.     ((and request-method (string-ci=? "POST" request-method))
  835.      (let ((content-length (getenv "CONTENT_LENGTH")))
  836.        (and content-length
  837.         (set! content-length (string->number content-length)))
  838.        (and content-length
  839.         (let ((str (make-string content-length #\ )))
  840.           (do ((idx 0 (+ idx 1)))
  841.               ((>= idx content-length)
  842.                (if (>= idx (string-length str))
  843.                str
  844.                (substring str 0 idx)))
  845.             (let ((chr (read-char)))
  846.               (if (char? chr)
  847.               (string-set! str idx chr)
  848.               (set! content-length idx))))))))
  849.     (else #f)))
  850.